perm filename GMATCH.124[AID,LSP] blob
sn#656530 filedate 1982-05-03 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00017 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00003 00002 The Matching Function
C00007 00003 Definitions for the Data Structures to be Matched
C00012 00004 Functions for Creating Function Names
C00013 00005 Macros for Unification
C00024 00006 Reader stuff to simplify typing and reading
C00032 00007 ?-RESTRICTIONS
C00036 00008 *-RESTRICTIONS
C00045 00009 *-IRESTRICTIONS
C00055 00010 ?-VARIABLE
C00058 00011 *-CLAUSE
C00062 00012 *-VARIABLE
C00066 00013 =?-VARIABLE
C00068 00014 Body
C00082 00015 The Unification Matcher
C00087 00016 Asymmetric Matcher
C00095 00017 Symmetric Matcher
C00103 ENDMK
C⊗;
;;;;;;;;;; The Matching Function ;;;;;;;;;;
;;;
;;; (arg 1) - p - pattern
;;; (arg 2) - d - data
;;; (arg 3) - alist - optional list of variables (* or ?) whose values
;;; are to be retained during the match, much like the
;;; = variables below.
;;; elements of a pattern:
;;; ? - matches anything
;;; * - matches one or more expressions
;;; ?<atom> - like "?", but sets ?<atom> to thing matched
;;; *<atom> - like "*", but sets *<atom> to list of things matched
;;; =<atom> - matched against value of <atom>
;;; (restrict <one of above ?-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil
;;; $r, ⊗r - same as RESTRICT
;;; (restrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given the list
;;; that is being considered for that variable as its argument
;;; (irestrict <one of above *-variables> <pred1> <pred2> .....)
;;; - the predi must eval to non-nil when given each element of the list
;;; that is being considered for that variable as its argument
;;; (done incrementally). So %MATCH will apply these predicates as
;;; it scans the input.
;;; $ir,⊗ir - same as irestrict
;;;
;;; (%match p d <variables to retain>) attempts to match p against d
;;; (%continue-match p d <variables to retain>) attempts to get the next
;;; possible match between p and d (by different *-variable
;;; bindings.
;;*PAGE
(DECLARE (SETQ DEFMACRO-FOR-COMPILING ()))
;;; Definitions for the Data Structures to be Matched
;;; Note: for every P- there is a D-
;;; P-ATOMIC is a predicate that determines if this item is
;;; one that can be examined for EQ
;;; P-CURRENT-ATOMIC tests whether the current item is recursive
;;; P-UNDECOMPSABLE is a predicate if tests if an object cannot
;;; be examined further P-UNDECOMPSABLE implies that it is
;;; a data structure outside the purview of the matcher, such
;;; as HUNKS in a tree matcher
;;; P-CURRENT returns the current item
;;; P-CURRENT-OBJECT returns the data structure of this object
;;; P-ADVANCE advances the object to the next
;;; P-VAR-TYPE returns the variable type of the p-atomic item supplied -
;;; has to return ?, *, =, and something else
;;; P-CHANGE-CURRENT changes the current item to the new value
;;; P-CHANGE changes the state so that the items supplied are the new items
;;; P-RESTRICT-VAR gets the restrict variable from the supplied current item
;;; P-MAP-BUILD like mapcar but with functions of 1 variable only and it
;;; operates on states
;;; P-EMPTY tests if P is empty
;;; P-CURRENT-EMPTY tests if the current element is empty
;;; P-LISTIFY turns P into a list
;;; P-LISTIFY-REST turns the rest of P into a list
;;; P-RESTRICT-FUNS returns the restrictions for the supplied current item
;;; P-RESTRICTP states whether an item is a restriction
;;; P-IRESTRICTP states whether an item is an incremental restriction
;;; P-FRESTRICTP states whether an item is a non-incremental restriction
;;; P-RESTRICT-VAR returns the restriction variable
;;; P-RESTRICT-TYPE return the type of restriction
;;; P-CREATE-RESTRICTION creates a restriction of the correct type from
;;; the parts supplied
;;; P-ADD-ITEM adds a new dummy item to the `front' of the data structure
;;; P-ADD-ITEMS adds new dummy items to the `front' of the data structure
;;; P-REST-EMPTY tests if the remainder of P is empty
;;; P-CREATE-STATE takes a data structure and returns a state suitable for
;;; the rest of the operations
;;; P-CHANGE-CURRENT-ITEMS replaces the current item with the items supplied
;;; P-CREATE-NULL-STATE creates a state with null content
;;; P-CREATE-STATE-FROM-CURRENT creates a state from the current item
;;; MATCH-NAME and MATCH-PREFIX ought to appear in the file as
;;; (EVAL-WHEN (COMPILE EVAL LOAD) (SETQ ..))
;;; P-CHECK is a function that is invoked before each assignment to
;;; a match variable. It has to take either a list of P-structures or
;;; a P data structure. In the Tree matcher's case it checks for circular
;;; structues and changes (-special-form- . x) into x
;;; Note, it does not take a STATE a may be defined for the above objects
;;; Functions for Creating Function Names
(EVAL-WHEN (COMPILE EVAL)
(OR (BOUNDP 'MATCH-PREFIX)
(SETQ MATCH-PREFIX '%%))
(OR (BOUNDP 'MATCH-NAME)
(SETQ MATCH-NAME '%UMATCH)))
(EVAL-WHEN (COMPILE EVAL)
(DEFUN CONCATENATE (X Y)
(IMPLODE (APPEND (EXPLODE X)
(EXPLODE Y))))
(DEFUN %%%MAKE-NAME%%% (X)
(IMPLODE (APPEND '#.(EXPLODE MATCH-PREFIX)
(EXPLODE X)))))
;;; Macros for Unification
(DECLARE (SPECIAL %/#CONTINUE %/#CONTINUE-STACK %/#RETAIN %/#CE %/#ALIST COMPILE-MACROS))
(DECLARE (SPECIAL %/#FULL-PREDICATE))
(SETQ %/#FULL-PREDICATE ())
;;; %/#CONTINUE is T if this is a rematch. %/#RETAIN says
;;; whether or not to save information for a rematch
;;; %/#CONTINUE-STACK saves * information for the rematch
(SETQ %/#CONTINUE NIL %/#CONTINUE-STACK NIL %/#RETAIN NIL COMPILE-MACROS NIL)
(DEFMACRO P-SPECIAL-FORM (X)
`(LET ((QQQ ,X))
(COND ((%%P-SPECIAL-FORMP QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(DEFMACRO D-SPECIAL-FORM (X)
`(LET ((QQQ ,X))
(COND ((%%D-SPECIAL-FORMP QQQ)
'-SPECIAL-FORM-)
(T QQQ))) )
(DEFMACRO CONSP (X) `(EQ (TYPEP ,X) 'LIST))
(DEFMACRO REAL-ATOM (%/#X)`(AND ,%/#X (ATOM ,%/#X)))
(DEFMACRO P-ALL-TRUE (FUN %/#L)
`(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (P-RESTRICTP %Q%)
(#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP) %Q%)
(FUNCALL ,FUN %Q%))
T))))
,%/#L)))
(DEFMACRO D-ALL-TRUE (FUN %/#L)
`(APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (%Q%)
(COND ((OR (D-RESTRICTP %Q%)
(#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP) %Q%)
(FUNCALL ,FUN %Q%))
T))))
,%/#L)))
(DEFMACRO EXCHANGE (X Y)
`((LAMBDA (Q)
(SETQ ,X ,Y)
(SETQ ,Y Q))
,X))
;(DEFUN %%P-REAL-FORM (X)
; (COND ((P-ATOMIC X) X)
; ((AND (CONSP X)
; (EQ (CAR X)) '-SPECIAL-FORM-)
; (CDR X))
; (T X)))
;(DEFUN %%D-REAL-FORM (X)
; (COND ((P-ATOMIC X) X)
; ((AND (CONSP X)
; (EQ (CAR X)) '-SPECIAL-FORM-)
; (CDR X))
; (T X)))
(DEFUN #.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP) (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(MEMQ (P-VAR-TYPE X) '(? * =))))
(T (OR (AND (CONSP X)
(EQ (CAR X) '-SPECIAL-FORM-))
(P-RESTRICTP X)))) )
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP) (X)
(COND (%/#FULL-PREDICATE ())
((ATOM X)
(OR (EQ X '-SPECIAL-FORM-)
(MEMQ (D-VAR-TYPE X) '(? * =))))
(T (OR (AND (CONSP X)
(EQ (CAR X) '-SPECIAL-FORM-))
(D-RESTRICTP X)))) )
(DEFMACRO ADD-ALIST (KEY VALUE ALIST)
` (CONS (CONS ,KEY ,VALUE) ,ALIST))
;;; Reader stuff to simplify typing and reading
(EVAL-WHEN (COMPILE EVAL)
(SETQ BACKQUOTE-EXPAND-WHEN 'EVAL))
(EVAL-WHEN (COMPILE EVAL)
(SETQ %VAR-LIST%
'(P D CP CD ALIST TAG RTAG P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
%%P-SPECIAL-FORMP
%%D-SPECIAL-FORMP
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY
#.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R))
%VAR-LIST-R%
'(D P CD CP ALIST TAG RTAG D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
%%D-SPECIAL-FORMP
%%P-SPECIAL-FORMP
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY
#.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R))
%ARG-LIST%
'`(,P ,D ,CP ,CD ,ALIST ,TAG ,RTAG ,P-ADVANCE ,D-ADVANCE
,P-CURRENT ,D-CURRENT ,P-RESTRICT-VAR ,D-RESTRICT-VAR
,P-CURRENT-ATOMIC ,D-CURRENT-ATOMIC
,P-CURRENT-EMPTY ,D-CURRENT-EMPTY
,P-EMPTY ,D-EMPTY ,P-CHANGE-CURRENT ,D-CHANGE-CURRENT
,P-CHANGE ,D-CHANGE ,P-CHANGE-CURRENT-ITEMS ,D-CHANGE-CURRENT-ITEMS
,P-ADD-ITEM ,D-ADD-ITEM ,P-ADD-ITEMS ,D-ADD-ITEMS
,P-RESTRICT-FUNS ,D-RESTRICT-FUNS
,%%P-SPECIAL-FORMP
,%%D-SPECIAL-FORMP
,P-CHECK
,D-CHECK
,P-CREATE-STATE-FROM-CURRENT ,D-CREATE-STATE-FROM-CURRENT
,P-ALL-TRUE ,D-ALL-TRUE
,P-ATOMIC ,D-ATOMIC
,P-RESTRICT-TYPE ,D-RESTRICT-TYPE
,P-IRESTRICTP ,D-IRESTRICTP
,P-FRESTRICTP ,D-FRESTRICTP
,P-CREATE-RESTRICTION ,D-CREATE-RESTRICTION
,P-VAR-TYPE ,D-VAR-TYPE ,P-CREATE-NULL-STATE ,D-CREATE-NULL-STATE
,P-LISTIFY ,D-LISTIFY ,P-LISTIFY-REST ,D-LISTIFY-REST
,P-RESTRICTP ,D-RESTRICTP
,P-SPECIAL-FORM ,D-SPECIAL-FORM
,P-REST-EMPTY ,D-REST-EMPTY
,#.(%%%MAKE-NAME%%% 'UMATCH)
,#.(%%%MAKE-NAME%%% 'UMATCH-R))
%ARG-LIST-R%
'`(,D ,P ,CD ,CP ,ALIST ,TAG ,RTAG ,D-ADVANCE ,P-ADVANCE
,D-CURRENT ,P-CURRENT ,D-RESTRICT-VAR ,P-RESTRICT-VAR
,D-CURRENT-ATOMIC ,P-CURRENT-ATOMIC
,D-CURRENT-EMPTY ,P-CURRENT-EMPTY
,D-EMPTY ,P-EMPTY ,D-CHANGE-CURRENT ,P-CHANGE-CURRENT
,D-CHANGE ,P-CHANGE ,D-CHANGE-CURRENT-ITEMS ,P-CHANGE-CURRENT-ITEMS
,D-ADD-ITEM ,P-ADD-ITEM ,D-ADD-ITEMS ,P-ADD-ITEMS
,D-RESTRICT-FUNS ,P-RESTRICT-FUNS
,%%D-SPECIAL-FORMP
,%%P-SPECIAL-FORMP
,D-CHECK
,P-CHECK
,D-CREATE-STATE-FROM-CURRENT ,P-CREATE-STATE-FROM-CURRENT
,D-ALL-TRUE ,P-ALL-TRUE
,D-ATOMIC ,P-ATOMIC
,D-RESTRICT-TYPE ,P-RESTRICT-TYPE
,D-IRESTRICTP ,P-IRESTRICTP
,D-FRESTRICTP ,P-FRESTRICTP
,D-CREATE-RESTRICTION ,P-CREATE-RESTRICTION
,D-VAR-TYPE ,P-VAR-TYPE ,D-CREATE-NULL-STATE ,P-CREATE-NULL-STATE
,D-LISTIFY ,P-LISTIFY ,D-LISTIFY-REST ,P-LISTIFY-REST
,D-RESTRICTP ,P-RESTRICTP
,D-SPECIAL-FORM ,P-SPECIAL-FORM
,D-REST-EMPTY ,P-REST-EMPTY
,#.(%%%MAKE-NAME%%% 'UMATCH)
,#.(%%%MAKE-NAME%%% 'UMATCH-R))))
(EVAL-WHEN (COMPILE EVAL)
(SETQ BACKQUOTE-EXPAND-WHEN 'READ))
;;; ?-RESTRICTIONS
(DEFMACRO CLAUSE-?-RESTRICTIONS #.%VAR-LIST%
`(COND
((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '?)
;;; normal case of ($r ? ...)
(COND ((,%%P-SPECIAL-FORMP (,D-CURRENT ,D))
(SETQ ,P
(,P-CHANGE-CURRENT ,P
(LIST '-SPECIAL-FORM- (,P-CURRENT ,P))))
(EXCHANGE ,P ,D)(EXCHANGE ,CP ,CD) (GO ,RTAG))
(T
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
;;; case of ($r ?foo ...)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T
(COND (
(*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,%%UMATCH-R ,D ,P ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(,D-CURRENT ,D) ,ALIST)
NOBIND))
(T (,%%UMATCH (,P-ADVANCE ,P)
(,D-ADVANCE ,D)
,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
(,D-CURRENT ,D)
,ALIST)
NOBIND)))
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT,P))
(,D-CHECK (,D-CURRENT
,D))))
(*THROW '%/#DECISION-POINT T )))))))))
;;; *-RESTRICTIONS
(DEFMACRO CLAUSE-*-RESTRICTIONS #.%VAR-LIST%
`(COND ((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '*)
(COND ((,P-EMPTY ,P)
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (,D-LISTIFY ,D))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(SETQ ,P
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM-
(,P-CURRENT ,P)))))
(EXCHANGE ,P ,D)(EXCHANGE ,CP ,CD) (GO,RTAG))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (LET (L)
(COND (%/#CONTINUE
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(OD ,D)
(OP ,P)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q L)
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP
(,D-CURRENT OD)))
(,%%UMATCH-R
OD OP ,CD ,CP ,ALIST NOBIND))
(T
(,%%UMATCH (,P-ADVANCE ,P)
,D ,CP ,CD
,ALIST NOBIND)))
)
(AND %/#RETAIN
(SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
)))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '*)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)))
(COND (%T% (COND((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (CDR %T%))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(SETQ ,P
(,P-ADD-ITEMS ,P
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT NIL ))))
((,P-REST-EMPTY ,P)
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((FUNCALL Q (,D-LISTIFY ,D))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
(
(*CATCH
'%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,%%UMATCH-R ,D ,P
,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
(CONS
(CONS
'-SPECIAL-FORM-
(,D-CURRENT ,D))
(,D-LISTIFY-REST ,D)) ,ALIST)
NOBIND))
(T
(,%%UMATCH
(CAR ,CP)
(CAR ,CD)
(CDR ,CP)
(CDR ,CD)
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
,D ,ALIST)
NOBIND))))
(OR NOBIND (SET (,P-RESTRICT-VAR
(,P-CURRENT ,P))
(,D-CHECK (,D-LISTIFY-REST ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P) )
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(OP ,P)
(OD ,D)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND((FUNCALL Q L)
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT OD)))
(,%%UMATCH OD OP ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P) )
(CONS
(CONS
'-SPECIAL-FORM-
(,D-CURRENT OD))
(CDR L)) ,ALIST)
NOBIND))
(T (,%%UMATCH
(,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR
(,P-CURRENT ,P))
L ,ALIST)
NOBIND)) )
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT ,P))
(,D-CHECK L)))
(*THROW '%/#DECISION-POINT T )))))))))))))
;;; *-IRESTRICTIONS
(DEFMACRO CLAUSE-*-IRESTRICTIONS #.%VAR-LIST%
`(COND ((EQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) '*)
(COND ((,P-REST-EMPTY ,P)
(COND
((APPLY 'AND
(MAPCAR (FUNCTION
(LAMBDA (Q)
(COND
((OR (,D-RESTRICTP ,D)
(,D-ALL-TRUE Q (,D-LISTIFY ,D)))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(SETQ ,P
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM- (,P-CURRENT ,P)))))
(EXCHANGE ,P ,D)(EXCHANGE ,CP ,CD)(GO ,RTAG))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (LET (L)
(COND (%/#CONTINUE
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(F (,D-CURRENT ,D)(,D-CURRENT ,D))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND ((APPLY 'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (NULL L)
(,D-RESTRICTP F)
(,%%D-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,%%UMATCH-R ,D (,P-ADVANCE ,P)
,CD ,CP ,ALIST NOBIND))
(T (,%%UMATCH (,P-ADVANCE ,P) ,D
,CP ,CD
,ALIST NOBIND)))
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))
)))
((EQ (,P-VAR-TYPE (,P-RESTRICT-FUNS (,P-CURRENT ,P))) '*)
(LET ((%T% (ASSQ (,P-RESTRICT-VAR (,P-CURRENT ,P)) ,ALIST)) )
(COND
(%T%
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (,P-RESTRICTP %T%)
(,P-ALL-TRUE Q %T%))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((*CATCH '%/#DECISION-POINT
(,%%UMATCH
(,P-CREATE-STATE-FROM-CURRENT ,P)
(,D-CREATE-STATE-FROM-CURRENT ,D) () () ,ALIST NOBIND)
)
(SETQ ,P
(,P-CHANGE-CURRENT-ITEMS (,P-ADVANCE ,P)
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT ()
))))
(T (*THROW '%/#DECISION-POINT NIL )))))))
((,P-REST-EMPTY ,P)
(COND ((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND
((OR (,D-RESTRICTP ,D)
(,D-ALL-TRUE
Q
(,D-LISTIFY ,D)))
T))))(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND ((OR (NOT (,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(*CATCH '%/#DECISION-POINT
(,%%UMATCH-R (,D-CREATE-STATE-FROM-CURRENT ,D)
(,P-CREATE-STATE-FROM-CURRENT ,P)
() ()
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(CONS (CONS '-SPECIAL-FORM- (,D-CURRENT ,D))
(,D-ADVANCE ,D)) ,ALIST)
NOBIND)
))
(COND ((*CATCH '%/#DECISION-POINT
(,%%UMATCH (CAR ,CP) (CAR ,CD) (CDR ,CP)
(CDR ,CD)
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
,D ,ALIST) NOBIND)
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT ,P)) (,D-CHECK ,D)))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(F (,D-CURRENT ,D)(,D-CURRENT ,D))
(OD ,D)
(OP ,P)
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((APPLY
'AND
(MAPCAR
(FUNCTION
(LAMBDA (Q)
(COND ((OR (NULL L)
(,D-RESTRICTP F)
(,%%D-SPECIAL-FORMP F)
(FUNCALL Q F))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P))))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L
(,%%D-SPECIAL-FORMP (CAR OD)))
(,%%UMATCH-R OD OP ,CD ,CP
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
(CONS (CONS
'-SPECIAL-FORM-
(CAR OD)) (CDR L))
,ALIST) NOBIND))
(T
(,%%UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST
(,P-RESTRICT-VAR (,P-CURRENT ,P))
L ,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-RESTRICT-VAR (,P-CURRENT ,P)) (,D-CHECK L)))
(*THROW '%/#DECISION-POINT T ))))))))))))
;;; ?-VARIABLE
(DEFMACRO CLAUSE-?-VARIABLE #.%VAR-LIST%
`(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T
(COND
((*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,%%UMATCH-R ,D ,P ,CD ,CP
(ADD-ALIST
(,P-CURRENT ,P)(,D-CURRENT ,D) ,ALIST) NOBIND))
(T
(,%%UMATCH (,P-ADVANCE ,P)(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,P-CURRENT ,P)
(,D-CURRENT ,D) ,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-CURRENT ,P) (,D-CHECK
(,D-CURRENT ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))))
;;; *-CLAUSE
(DEFMACRO CLAUSE-* #.%VAR-LIST%
`(COND ((,P-REST-EMPTY ,P)
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(SETQ ,P
(,P-CHANGE ,P
(NCONS (CONS '-SPECIAL-FORM- (,P-CURRENT ,P)))) )
(EXCHANGE ,P ,D)(EXCHANGE ,CP ,CD)(GO ,RTAG))
(T
(SETQ ,P (CAR ,CP) ,D (CAR ,CD)
,CP (CDR ,CP) ,CD (CDR ,CD))(GO ,TAG))))
(T (LET (L)
(COND (%/#CONTINUE
;(OR %/#CONTINUE-STACK (*THROW '%/#DECISION-POINT NIL ))
;;; initialize for continuation
(SETQ L (PROG2 NIL (CAR %/#CONTINUE-STACK)
(SETQ %/#CONTINUE-STACK
(CDR %/#CONTINUE-STACK))))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
;;; try all possibilities
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND
((AND L
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,%%UMATCH-R ,D (,P-ADVANCE ,P) ,CP ,CD ,ALIST NOBIND))
(T (,%%UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD ,ALIST NOBIND) ))
)
(AND %/#RETAIN (SETQ %/#CONTINUE-STACK
(CONS L %/#CONTINUE-STACK)))
(*THROW '%/#DECISION-POINT T )))))))))
;;; *-VARIABLE
(DEFMACRO CLAUSE-*-VARIABLE #.%VAR-LIST%
`(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T% (SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P (,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
((,P-REST-EMPTY ,P)
(COND
((*CATCH '%/#DECISION-POINT
(COND ((,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(,%%UMATCH-R ,D (,P-CHANGE-CURRENT ,P (CONS '-SPECIAL-FORM-
(,P-CURRENT ,P)))
,CD ,CP
(ADD-ALIST (,P-CURRENT ,P) ,D ,ALIST)
NOBIND))
(T (,%%UMATCH (CAR ,CP) (CAR ,CD) (CDR ,CP)
(CDR ,CD)
(ADD-ALIST (,P-CURRENT ,P) ,D
,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-CURRENT ,P) (,D-CHECK (,D-LISTIFY ,D))))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))
(T (LET (L)
(COND (%/#CONTINUE
(SETQ L (SYMEVAL (,P-CURRENT ,P)))
(SETQ ,D (DO ((L L (CDR L))
(,D ,D (,D-ADVANCE ,D)))
((NULL L) ,D)))
(COND ((,D-EMPTY ,D)
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))))
(T (SETQ L NIL)))
(DO ((L L (NCONC L (NCONS (,D-CURRENT ,D))))
(,D ,D (,D-ADVANCE ,D))
(E (,D-ADD-ITEM ,D NIL) (,D-ADVANCE E)))
((,D-EMPTY E) (*THROW '%/#DECISION-POINT NIL ))
(COND
((*CATCH '%/#DECISION-POINT
(COND ((AND L (,%%D-SPECIAL-FORMP (,D-CURRENT ,D)))
(,%%UMATCH-R ,D (,P-ADVANCE ,P)
,CD ,CP (ADD-ALIST (,P-CURRENT ,P) L
,ALIST) NOBIND))
(T (,%%UMATCH (,P-ADVANCE ,P) ,D ,CP ,CD
(ADD-ALIST (,P-CURRENT ,P) L
,ALIST) NOBIND)))
)
(OR NOBIND (SET (,P-CURRENT ,P) (,D-CHECK L)))
(*THROW '%/#DECISION-POINT T )))))))))
;;; =?-VARIABLE
(DEFMACRO CLAUSE-=?-VARIABLE #.%VAR-LIST%
`(LET ((%T% (CDR (EXPLODE (,P-CURRENT ,P)))))
(COND ((EQ (CAR %T%) '?)
(LET ((VAR (IMPLODE %T%)))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL (SETQ ,P
(,P-CHANGE-CURRENT ,P
(CDR VAL))))
(T
(SETQ ,P (,P-CHANGE-CURRENT ,P
(SYMEVAL VAR)))))
(GO ,TAG))))
(T
(LET ((VAR (IMPLODE %T%)))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL (SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P (CDR VAL))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P
(SYMEVAL VAR)))))
(GO ,TAG)))))))
;;; Body
(DEFMACRO BODY #.%VAR-LIST%
`(OR
(COND
;;; no more pattern
((AND (NULL ,P)
(NULL ,D)
(NULL ,CP)
(NULL ,CD))
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
((AND (,P-EMPTY ,P) (NULL ,CP))
;;; so there had better be no more data, unless there are some * vars etc
(COND ((AND (,D-EMPTY ,D)(NULL ,CD))
;;; if this is a reUMATCH, we back up for next try
(COND (%/#CONTINUE (SETQ %/#CONTINUE NIL)
(*THROW '%/#DECISION-POINT NIL ))
;;; otherwise success
((*THROW '%/#DECISION-POINT T ))))
;;; more data loses in some cases
(T (COND ((OR (,D-ATOMIC ,D)
(,D-RESTRICTP ,D))
;;; if D=?<var> or = nil
(SETQ ,D (,D-CHANGE ,D (NCONS ,D))
,P (,P-CHANGE ,P (NCONS NIL)))
(GO ,TAG))
((EQ (,D-CURRENT ,D) '*)
;;; D=(* ...) could work if (CDR D) is all *-variables
(SETQ ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; we succeed if (CAR D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,D-CURRENT ,D) ,ALIST)))
(COND (%T% (SETQ ,D (,D-CHANGE-CURRENT-ITEMS
,D (,D-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,%%UMATCH
(,P-CREATE-NULL-STATE)
(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,D-CURRENT ,D)
NIL
,ALIST) NOBIND) )
(OR NOBIND (SET (,D-CURRENT ,D) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))) )
(T (*THROW '%/#DECISION-POINT NIL ))))))
((,P-EMPTY ,P)
;;; if P is null, but D isn't, something is wrong sometimes
(COND ((NOT (,D-EMPTY ,D))
(COND ((OR (,D-ATOMIC ,D)
(,D-RESTRICTP ,D))
;;; if D=?<var> or = nil
(SETQ ,D (,D-CHANGE ,D (NCONS ,D))
,P (,P-CHANGE ,P (NCONS NIL)))
(GO ,TAG))
((EQ (,D-CURRENT ,D) '*)
;;; D=(* ...) could work if (CDR D) is all *-variables
(SETQ ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; we succeed if (CAR D) = (*<var> ...)
;;; and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,D-CURRENT ,D) ,ALIST)))
(COND (%T%
(SETQ ,D (,D-CHANGE-CURRENT-ITEMS ,D
(,D-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,%%UMATCH
(,P-CREATE-NULL-STATE)
(,D-ADVANCE ,D) ,CP ,CD
(ADD-ALIST (,D-CURRENT ,D) NIL
,ALIST) NOBIND) )
(OR NOBIND (SET (,D-CURRENT ,D) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () ))))) ))
(T (*THROW '%/#DECISION-POINT NIL ))))
(T (SETQ ,P (CAR ,CP) ,D (CAR ,CD) ,CP (CDR ,CP) ,CD (CDR ,CD))
(GO ,TAG))))
((AND (,D-EMPTY ,D)
(NOT (,P-RESTRICTP (,P-CURRENT ,P))))
;;; if D is null and P isn't, we can still win
(COND ((OR (,P-ATOMIC ,P)
(,P-RESTRICTP ,P))
;;; if P=?<var> or = nil
(SETQ ,P (,P-CHANGE ,P (NCONS ,P))
,D (,D-CHANGE ,D (NCONS NIL)))
(GO ,TAG))
((EQ (,P-CURRENT ,P) '*)
;;; P=(* ...) could work if (CDR P) is all *-variables
(SETQ ,P (,P-ADVANCE ,P))
(GO ,TAG))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '*)
;;; we succeed if (CAR P) = (*<var> ...) and *<var> UMATCHed 0 elements.
(LET ((%T% (ASSQ (,P-CURRENT ,P) ,ALIST)))
(COND (%T%
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS ,P
(,P-SPECIAL-FORM (CDR %T%))))
(GO ,TAG))
(T (COND ((*CATCH '%/#DECISION-POINT
(,%%UMATCH (,P-ADVANCE ,P)
(,D-CREATE-NULL-STATE)
,CP ,CD
(ADD-ALIST
(,P-CURRENT ,P) NIL
,ALIST) NOBIND) )
(OR NOBIND (SET (,P-CURRENT ,P) NIL))
(*THROW '%/#DECISION-POINT T ))
(T (*THROW '%/#DECISION-POINT () )))))) )
))
((OR (,P-ATOMIC ,P) (,D-ATOMIC ,D))
;;; here we listify things if necessary
(SETQ ,P (,P-CHANGE ,P (NCONS ,P))
,D (,D-CHANGE ,D (NCONS ,D)))
(GO ,TAG))
;;; ? restrictions
((AND (,P-RESTRICTP (,P-CURRENT ,P))
(EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
(NOT (,D-EMPTY ,D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (PRED) (COND ((OR (,D-RESTRICTP (,D-CURRENT ,D))
(,%%D-SPECIAL-FORMP (,D-CURRENT ,D))
(FUNCALL PRED (,D-CURRENT ,D)))
T))))
(,P-RESTRICT-FUNS (,P-CURRENT ,P)))))
(COND ((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '?)
(CLAUSE-?-RESTRICTIONS . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '=)
(LET ((VAR
(IMPLODE
(CDR (EXPLODE (,P-RESTRICT-VAR (,P-CURRENT ,P)))))))
(LET ((VAL (ASSQ VAR ,ALIST)))
(COND (VAL
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))
,ALIST
(ADD-ALIST VAR (SYMEVAL VAR)
,ALIST))))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT () ))))
((,P-FRESTRICTP (,P-CURRENT ,P))
(CLAUSE-*-RESTRICTIONS . ,#.%ARG-LIST%))
((,P-IRESTRICTP (,P-CURRENT ,P))
(CLAUSE-*-IRESTRICTIONS . ,#.%ARG-LIST%))
((EQ (,P-CURRENT ,P) '*)
;;; (* ...)
(CLAUSE-* . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE . ,#.%ARG-LIST%))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '=)
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE . ,#.%ARG-LIST%))
((AND (,D-RESTRICTP (,D-CURRENT ,D))
(APPLY 'AND
(MAPCAR
(FUNCTION (LAMBDA (PRED) (COND ((OR (,P-RESTRICTP
(,P-CURRENT ,P))
(,%%P-SPECIAL-FORMP (,P-CURRENT ,P))
(FUNCALL PRED (,P-CURRENT ,P)))
T))))
(,D-RESTRICT-FUNS (,D-CURRENT ,D)))))
(COND ((EQ (,D-VAR-TYPE (,D-RESTRICT-VAR (,D-CURRENT ,D))) '?)
(COND ((,P-EMPTY ,P)(*THROW '%/#DECISION-POINT ()))
(T (CLAUSE-?-RESTRICTIONS . ,#.%ARG-LIST-R%))))
((EQ (,P-VAR-TYPE (,P-RESTRICT-VAR (,P-CURRENT ,P))) '=)
(LET ((VAR
(IMPLODE
(CDR (EXPLODE (,P-RESTRICT-VAR (,P-CURRENT ,P)))))))
(LET ((VAL
(ASSQ VAR ,ALIST)))
(COND (VAL
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))))
(T
(SETQ ,P (,P-CHANGE-CURRENT-ITEMS
,P
(,P-CREATE-RESTRICTION
(,P-RESTRICT-TYPE (,P-CURRENT ,P))
VAR (,P-RESTRICT-FUNS (,P-CURRENT ,P))))
,ALIST
(ADD-ALIST VAR (SYMEVAL VAR)
,ALIST))))))
(GO ,TAG))
(T (*THROW '%/#DECISION-POINT () ))))
((,D-FRESTRICTP (,D-CURRENT ,D))
(CLAUSE-*-RESTRICTIONS . ,#.%ARG-LIST%))
((,D-IRESTRICTP (,D-CURRENT ,D))
(CLAUSE-*-IRESTRICTIONS .,#.%ARG-LIST-R%))
((EQ (,D-CURRENT ,D) '*)
;;; (* ...)
(CLAUSE-* . ,#.%ARG-LIST-R%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '*)
;;; similar for (*foo ...)
(CLAUSE-*-VARIABLE . ,#.%ARG-LIST-R%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '=)
;;; (=?foo ...)
(CLAUSE-=?-VARIABLE . ,#.%ARG-LIST-R%))
((OR (EQUAL (,P-CURRENT ,P) (,D-CURRENT ,D)) (EQ (,P-CURRENT ,P) '?) (EQ (,D-CURRENT ,D) '?))
;;; easiest case
(SETQ ,P (,P-ADVANCE ,P) ,D (,D-ADVANCE ,D))
(GO ,TAG))
((EQ (,P-VAR-TYPE (,P-CURRENT ,P)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE . ,#.%ARG-LIST%))
((EQ (,D-VAR-TYPE (,D-CURRENT ,D)) '?)
;;; (?foo ...)
(CLAUSE-?-VARIABLE . ,#.%ARG-LIST-R%))
((AND (NOT (,P-CURRENT-ATOMIC ,P))
(OR (,D-CURRENT-EMPTY ,D)
(NOT (,D-CURRENT-ATOMIC ,D))))
;;; the big recursion
;;; notice that we want nil to be a list here, not an atom
;;; since ((*) ...) (nil ...) needs a chance
(SETQ
,CP (CONS (,P-ADVANCE ,P) ,CP)
,CD (CONS (,D-ADVANCE ,D) ,CD)
,P (,P-CREATE-STATE-FROM-CURRENT ,P) ,D (,D-CREATE-STATE-FROM-CURRENT ,D))
(GO ,TAG)))
(*THROW '%/#DECISION-POINT () )))
;;*page
;;; The Unification Matcher
;;; Matches 2 patterns.
(DECLARE (SPECIAL #.(%%%MAKE-NAME%%% 'STATISTICS)
#.(%%%MAKE-NAME%%% 'CALLS))
(FIXNUM #.(%%%MAKE-NAME%%% 'CALLS)))
(SETQ #.(%%%MAKE-NAME%%% 'STATISTICS) () #.(%%%MAKE-NAME%%% 'CALLS) 0)
(DEFUN #.(%%%MAKE-NAME%%% 'CALLS) () #.(%%%MAKE-NAME%%% 'CALLS))
(DEFUN #.(%%%MAKE-NAME%%% 'STATISTICS) (X)
(AND X (SETQ #.(%%%MAKE-NAME%%% 'CALLS) 0))
(SETQ #.(%%%MAKE-NAME%%% 'STATISTICS) X))
;;; (%UMATCH <pat> <data> <initial alist, optional>)
(DEFUN #.MATCH-NAME %/#n
(AND #.(%%%MAKE-NAME%%% 'STATISTICS)
(SETQ #.(%%%MAKE-NAME%%% 'CALLS)
(1+ #.(%%%MAKE-NAME%%% 'CALLS))))
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) ()) )) NIL))
;;; (CONTINUE-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-CONTINUE) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4)))) ()) ))
T))
;;; (UMATCH-NOBIND <pat> <data> <initial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-NOBIND) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK NIL)
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 2 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 3)))) T) )) NIL))
;;; (CONTINUE-NOBIND-UMATCH <pat> <data> <* stack> <intitial alist, optional>)
(DEFUN #.(CONCATENATE MATCH-NAME '-CONTINUE-NOBIND) %/#n
((LAMBDA(%/#CONTINUE)
(SETQ %/#CONTINUE-STACK (ARG 3))
(*CATCH '%/#DECISION-POINT
(#.(%%%MAKE-NAME%%% 'UMATCH)
(P-CREATE-STATE (ARG 1))
#+SYMMETRIC(P-CREATE-STATE (ARG 2))
#-SYMMETRIC(D-CREATE-STATE (ARG 2))
NIL NIL
(COND ((< 3 %/#n)(MAPCAR (FUNCTION (LAMBDA(%/#Q)(CONS %/#Q (SYMEVAL %/#Q))))
(ARG 4)))) T) ))
T))
;;; Asymmetric Matcher
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH) (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH UMATCH-R P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY #.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R))
UMATCH-R
(BODY
%/#D %/#P %/#CD %/#CP %/#ALIST UMATCH UMATCH-R D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY #.(%%%MAKE-NAME%%% 'UMATCH-R)
#.(%%%MAKE-NAME%%% 'UMATCH))))
#-SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH-R) (%/#D %/#P %/#CD %/#CP %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#D %/#P %/#CD %/#CP %/#ALIST UMATCH-R UMATCH D-ADVANCE P-ADVANCE
D-CURRENT P-CURRENT D-RESTRICT-VAR P-RESTRICT-VAR
D-CURRENT-ATOMIC P-CURRENT-ATOMIC
D-CURRENT-EMPTY P-CURRENT-EMPTY
D-EMPTY P-EMPTY D-CHANGE-CURRENT P-CHANGE-CURRENT
D-CHANGE P-CHANGE D-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
D-ADD-ITEM P-ADD-ITEM D-ADD-ITEMS P-ADD-ITEMS
D-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
D-CHECK
P-CHECK
D-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
D-ALL-TRUE P-ALL-TRUE
D-ATOMIC P-ATOMIC
D-RESTRICT-TYPE P-RESTRICT-TYPE
D-IRESTRICTP P-IRESTRICTP
D-FRESTRICTP P-FRESTRICTP
D-CREATE-RESTRICTION P-CREATE-RESTRICTION
D-VAR-TYPE P-VAR-TYPE D-CREATE-NULL-STATE P-CREATE-NULL-STATE
D-LISTIFY P-LISTIFY D-LISTIFY-REST P-LISTIFY-REST
D-RESTRICTP P-RESTRICTP
D-SPECIAL-FORM P-SPECIAL-FORM
D-REST-EMPTY P-REST-EMPTY #.(%%%MAKE-NAME%%% 'UMATCH)
#.(%%%MAKE-NAME%%% 'UMATCH-R))
UMATCH-R
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH-R UMATCH P-ADVANCE D-ADVANCE
P-CURRENT D-CURRENT P-RESTRICT-VAR D-RESTRICT-VAR
P-CURRENT-ATOMIC D-CURRENT-ATOMIC
P-CURRENT-EMPTY D-CURRENT-EMPTY
P-EMPTY D-EMPTY P-CHANGE-CURRENT D-CHANGE-CURRENT
P-CHANGE D-CHANGE P-CHANGE-CURRENT-ITEMS D-CHANGE-CURRENT-ITEMS
P-ADD-ITEM D-ADD-ITEM P-ADD-ITEMS D-ADD-ITEMS
P-RESTRICT-FUNS D-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'D-SPECIAL-FORMP)
P-CHECK
D-CHECK
P-CREATE-STATE-FROM-CURRENT D-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE D-ALL-TRUE
P-ATOMIC D-ATOMIC
P-RESTRICT-TYPE D-RESTRICT-TYPE
P-IRESTRICTP D-IRESTRICTP
P-FRESTRICTP D-FRESTRICTP
P-CREATE-RESTRICTION D-CREATE-RESTRICTION
P-VAR-TYPE D-VAR-TYPE P-CREATE-NULL-STATE D-CREATE-NULL-STATE
P-LISTIFY D-LISTIFY P-LISTIFY-REST D-LISTIFY-REST
P-RESTRICTP D-RESTRICTP
P-SPECIAL-FORM D-SPECIAL-FORM
P-REST-EMPTY D-REST-EMPTY #.(%%%MAKE-NAME%%% 'UMATCH-R) #.(%%%MAKE-NAME%%% 'UMATCH)) ))
;;; Symmetric Matcher
;;; %/#P is the pattern
;;; %/#D is the data
;;; %/#CP is the pattern to UMATCH against %/#CD if %/#P and %/#D UMATCH (i.e. a continuation)
;;; %/#CD is the data for the continuation
;;; ALIST is the current alist
#+SYMMETRIC
(DEFUN #.(%%%MAKE-NAME%%% 'UMATCH) (%/#P %/#D %/#CP %/#CD %/#ALIST NOBIND)
(PROG NIL
UMATCH
(BODY
%/#P %/#D %/#CP %/#CD %/#ALIST UMATCH UMATCH P-ADVANCE P-ADVANCE
P-CURRENT P-CURRENT P-RESTRICT-VAR P-RESTRICT-VAR
P-CURRENT-ATOMIC P-CURRENT-ATOMIC
P-CURRENT-EMPTY P-CURRENT-EMPTY
P-EMPTY P-EMPTY P-CHANGE-CURRENT P-CHANGE-CURRENT
P-CHANGE P-CHANGE P-CHANGE-CURRENT-ITEMS P-CHANGE-CURRENT-ITEMS
P-ADD-ITEM P-ADD-ITEM P-ADD-ITEMS P-ADD-ITEMS
P-RESTRICT-FUNS P-RESTRICT-FUNS
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
#.(%%%MAKE-NAME%%% 'P-SPECIAL-FORMP)
P-CHECK
P-CHECK
P-CREATE-STATE-FROM-CURRENT P-CREATE-STATE-FROM-CURRENT
P-ALL-TRUE P-ALL-TRUE
P-ATOMIC P-ATOMIC
P-RESTRICT-TYPE P-RESTRICT-TYPE
P-IRESTRICTP P-IRESTRICTP
P-FRESTRICTP P-FRESTRICTP
P-CREATE-RESTRICTION P-CREATE-RESTRICTION
P-VAR-TYPE P-VAR-TYPE P-CREATE-NULL-STATE P-CREATE-NULL-STATE
P-LISTIFY P-LISTIFY P-LISTIFY-REST P-LISTIFY-REST
P-RESTRICTP P-RESTRICTP
P-SPECIAL-FORM P-SPECIAL-FORM
P-REST-EMPTY P-REST-EMPTY #.(%%%MAKE-NAME%%% 'UMATCH) #.(%%%MAKE-NAME%%% 'UMATCH))))